home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tclX-6.4 / buildidx.tcl < prev    next >
Encoding:
Text File  |  1992-12-17  |  3.1 KB  |  100 lines
  1. #
  2. # buildidx.tcl --
  3. #
  4. # Code to build Tcl package library. Defines the proc `buildpackageindex'.
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: buildidx.tcl,v 2.0 1992/10/16 04:51:38 markd Rel $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. proc TCHSH:PutLibLine {outfp package where endwhere autoprocs} {
  21.     puts $outfp [concat $package $where [expr {$endwhere - $where - 1}] \
  22.                         $autoprocs]
  23. }
  24.  
  25. proc TCLSH:CreateLibIndex {libName} {
  26.  
  27.     if {[file extension $libName] != ".tlib"} {
  28.         error "Package library `$libName' does not have the extension `.tlib'"}
  29.     set idxName "[file root $libName].tndx"
  30.  
  31.     unlink -nocomplain $idxName
  32.     set libFH [open $libName r]
  33.     set idxFH [open $idxName w]
  34.  
  35.     set contectHdl [scancontext create]
  36.  
  37.     scanmatch $contectHdl "^#@package: " {
  38.         set size [llength $matchInfo(line)]
  39.         if {$size < 2} {
  40.             error [format "invalid package header \"%s\"" $matchInfo(line)]
  41.         }
  42.         if $inPackage {
  43.             TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere \
  44.                              $matchInfo(offset) $pkgDefProcs
  45.         }
  46.         set pkgDefName   [lindex $matchInfo(line) 1]
  47.         set pkgDefWhere  [tell $matchInfo(handle)]
  48.         set pkgDefProcs  [lrange $matchInfo(line) 2 end]
  49.         set inPackage 1
  50.     }
  51.  
  52.     scanmatch $contectHdl "^#@packend" {
  53.         if !$inPackage {
  54.             error "#@packend without #@package in $libName
  55.         }
  56.         TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere $matchInfo(offset) \
  57.                          $pkgDefProcs
  58.         set inPackage 0
  59.     }
  60.  
  61.     set inPackage 0
  62.     if {[catch {
  63.         scanfile $contectHdl $libFH
  64.        } msg] != 0} {
  65.        global errorInfo errorCode
  66.        close libFH
  67.        close idxFH
  68.        error $msg $errorInfo $errorCode
  69.     }
  70.     if {![info exists pkgDefName]} {
  71.         error "No #@package definitions found in $libName"
  72.     }
  73.     if $inPackage {
  74.         TCHSH:PutLibLine $idxFH $pkgDefName $pkgDefWhere [tell $libFH] \
  75.                          $pkgDefProcs
  76.     }
  77.     close $libFH
  78.     close $idxFH
  79.     
  80.     scancontext delete $contectHdl
  81.  
  82.     # Set mode and ownership of the index to be the same as the library.
  83.  
  84.     file stat $libName statInfo
  85.     chmod $statInfo(mode) $idxName
  86.     chown [list $statInfo(uid) $statInfo(gid)] $idxName
  87.  
  88. }
  89.  
  90. proc buildpackageindex {libfile} {
  91.  
  92.     set status [catch {TCLSH:CreateLibIndex $libfile} errmsg]
  93.     if {$status != 0} {
  94.         global errorInfo errorCode
  95.         error "building package index for `$libfile' failed: $errmsg" \
  96.               $errorInfo $errorCode
  97.     }
  98. }
  99.  
  100.